home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
os2
/
adaptor.zip
/
ADAPT.ZIP
/
adaptor
/
src
/
semantic.c
< prev
next >
Wrap
Text File
|
1994-01-03
|
55KB
|
2,396 lines
# include "Semantic.h"
# include "yySemant.w"
# include <stdio.h>
# if defined __STDC__ | defined __cplusplus
# include <stdlib.h>
# else
extern void exit ();
# endif
# include "Tree.h"
# include "Definiti.h"
# ifndef NULL
# define NULL 0L
# endif
# ifndef false
# define false 0
# endif
# ifndef true
# define true 1
# endif
# ifdef yyInline
# define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) \
if ((ptr = (tree) free) >= (tree) max) ptr = alloc (); \
free += nodesize [kind]; \
ptr->yyHead.yyMark = 0; \
ptr->Kind = kind;
# else
# define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) ptr = make (kind);
# endif
# define yyWrite(s) (void) fputs (s, yyf)
# define yyWriteNl (void) fputc ('\n', yyf)
# line 44 "Semantic.puma"
# include "Idents.h"
# include "StringMe.h"
# include "Types.h"
# include "protocol.h"
# include "Globals.h" /* CheckGlobalGetParams, CheckGlobalSendParams */
# include "SemDecls.h" /* SemDefinitions, SemDeclarations */
# include "SemExp.h" /* SemExp, SemExpList */
/*********************************************************************
* *
* Global Data for Semantic Analysis *
* *
*********************************************************************/
static tTree current_unit;
/*********************************************************************
* *
* allocate_stack: *
* MAX_ALLOCATES *
* ------------------------- *
* | | *
* ------------------------- *
* | | *
* | ............... | *
* | | *
* ------------------------- *
* | | 3 <- allocate_top *
* ------------------------- *
* | alloc_var 3 | 2 *
* ------------------------- *
* | alloc_var 2 | 1 *
* ------------------------- *
* | alloc_var 1 | 0 *
* ------------------------- *
* *
*********************************************************************/
# define MAX_ALLOCATES 100
static int allocate_top;
static tIdent allocate_stack [MAX_ALLOCATES];
/*************************************************
* *
* Check that allocate_stack is empty at the end *
* *
*************************************************/
void DeallocateCheck ()
{ int i;
char name[100], msg[130];
for (i=allocate_top-1; i>=0; i--)
{ /* missing deallocate for allocate_stack[i] */
GetString (allocate_stack[i], name);
sprintf (msg, "Missing DEALLOCATE for %s", name);
simple_error_protocol (msg);
}
} /* DeallocateCheck */
/*************************************************
* *
* Check if name has been allocated *
* *
*************************************************/
bool IsAllocated (var)
tIdent var;
{ bool found;
int i;
i = 0;
found = false;
while ((i < allocate_top) && (!found))
{ found = (allocate_stack[i] == var);
if (!found) i+=1;
}
return found;
} /* IsAllocated */
static FILE * yyf = stdout;
static void yyAbort
# ifdef __cplusplus
(char * yyFunction)
# else
(yyFunction) char * yyFunction;
# endif
{
(void) fprintf (stderr, "Error: module Semantic, routine %s failed\n", yyFunction);
exit (1);
}
void Semantic ARGS((tTree t));
static void BodyCheck ARGS((tTree body, tTree unit));
static void SemanticWhere ARGS((tTree t, int whererank));
static void SemanticForall ARGS((tTree t));
static void ForallLoopVarCheck ARGS((tTree loop, tTree var));
static void SemanticIO ARGS((tTree t));
static void SemReadParams ARGS((tTree items));
static tTree MakeDoVar ARGS((tTree DoExp));
void SemanticCall ARGS((tTree t, tDefinitions p));
static void SemanticCallParams ARGS((tTree a, tTree f, tDefinitions d));
static void SemanticMatchParam ARGS((tTree actual, tDefinitions formal));
static void AnalIntrinsicSubroutine ARGS((tIdent name, tTree params));
static void CheckReduceParams ARGS((tTree t));
static void CheckRandomParams ARGS((tTree t));
static void CheckRandomTypes ARGS((tTree type, tTree limit));
static void CheckRandomizeParams ARGS((tTree t));
static void CheckWalltimeParams ARGS((tTree t));
static void CheckTimerParams ARGS((tTree t));
static void CheckAllocateParams ARGS((tTree t));
static void NormalAllocateParams ARGS((tTree t));
static void CheckDeallocateParams ARGS((tTree t));
static bool IsVarParameter ARGS((tTree t));
static void CheckLHSVar ARGS((tTree t));
static void SemPureCheck ARGS((tTree t));
void Semantic
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
# line 130 "Semantic.puma"
char string[256];
tObject Obj, Obj1;
int dist;
bool okay;
switch (t->Kind) {
case kCOMP_UNIT:
# line 143 "Semantic.puma"
{
# line 144 "Semantic.puma"
open_protocol ("adaptor.sem");
# line 145 "Semantic.puma"
Semantic (t->COMP_UNIT.COMP_ELEMENTS);
# line 146 "Semantic.puma"
close_protocol ();
}
return;
case kDECL_EMPTY:
# line 151 "Semantic.puma"
return;
case kDECL_LIST:
# line 154 "Semantic.puma"
{
# line 155 "Semantic.puma"
Semantic (t->DECL_LIST.Elem);
# line 156 "Semantic.puma"
Semantic (t->DECL_LIST.Next);
}
return;
case kPROGRAM_DECL:
# line 169 "Semantic.puma"
{
tDefinitions Obj;
{
# line 170 "Semantic.puma"
set_protocol_unit (t);
# line 171 "Semantic.puma"
current_unit = t;
# line 172 "Semantic.puma"
IsPure = false;
# line 173 "Semantic.puma"
# line 174 "Semantic.puma"
Obj = GetDeclEntry (t->PROGRAM_DECL.Name, GetUnitEntries ());
# line 175 "Semantic.puma"
OpenScope (Obj->ProcObject.Declarations);
# line 176 "Semantic.puma"
SemDefinitions (GetCurrentScope ());
# line 177 "Semantic.puma"
Semantic (t->PROGRAM_DECL.PROGRAM_BODY);
# line 178 "Semantic.puma"
CloseScope ();
}
return;
}
case kPROC_DECL:
# line 181 "Semantic.puma"
{
tDefinitions Obj;
{
# line 182 "Semantic.puma"
set_protocol_unit (t);
# line 183 "Semantic.puma"
current_unit = t;
# line 184 "Semantic.puma"
IsPure = t->PROC_DECL.IsPure;
# line 185 "Semantic.puma"
# line 186 "Semantic.puma"
Obj = GetDeclEntry (t->PROC_DECL.Name, GetUnitEntries ());
# line 187 "Semantic.puma"
OpenScope (Obj->ProcObject.Declarations);
# line 188 "Semantic.puma"
SemDefinitions (GetCurrentScope ());
# line 189 "Semantic.puma"
Semantic (t->PROC_DECL.PROC_BODY);
# line 190 "Semantic.puma"
CloseScope ();
}
return;
}
case kFUNC_DECL:
# line 193 "Semantic.puma"
{
tDefinitions Obj;
{
# line 194 "Semantic.puma"
set_protocol_unit (t);
# line 195 "Semantic.puma"
current_unit = t;
# line 196 "Semantic.puma"
IsPure = t->FUNC_DECL.IsPure;
# line 197 "Semantic.puma"
# line 198 "Semantic.puma"
Obj = GetDeclEntry (t->FUNC_DECL.Name, GetUnitEntries ());
# line 199 "Semantic.puma"
OpenScope (Obj->FuncObject.Declarations);
# line 200 "Semantic.puma"
SemDefinitions (GetCurrentScope ());
# line 201 "Semantic.puma"
Semantic (t->FUNC_DECL.FUNC_BODY);
# line 202 "Semantic.puma"
CloseScope ();
}
return;
}
case kMODULE_DECL:
# line 205 "Semantic.puma"
{
tDefinitions Obj;
{
# line 206 "Semantic.puma"
set_protocol_unit (t);
# line 207 "Semantic.puma"
current_unit = t;
# line 208 "Semantic.puma"
IsPure = false;
# line 209 "Semantic.puma"
# line 210 "Semantic.puma"
Obj = GetDeclEntry (t->MODULE_DECL.Name, GetUnitEntries ());
# line 211 "Semantic.puma"
OpenScope (Obj->ModuleObject.Declarations);
# line 212 "Semantic.puma"
SemDefinitions (GetCurrentScope ());
# line 213 "Semantic.puma"
Semantic (t->MODULE_DECL.MODULE_BODY);
# line 214 "Semantic.puma"
CloseScope ();
}
return;
}
case kBLOCK_DATA_DECL:
# line 217 "Semantic.puma"
{
tDefinitions Obj;
{
# line 218 "Semantic.puma"
set_protocol_unit (t);
# line 219 "Semantic.puma"
current_unit = t;
# line 220 "Semantic.puma"
IsPure = false;
# line 221 "Semantic.puma"
# line 222 "Semantic.puma"
Obj = GetDeclEntry (t->BLOCK_DATA_DECL.Name, GetUnitEntries ());
# line 223 "Semantic.puma"
OpenScope (Obj->BlockObject.Declarations);
# line 224 "Semantic.puma"
SemDefinitions (GetCurrentScope ());
# line 225 "Semantic.puma"
Semantic (t->BLOCK_DATA_DECL.DATA_BODY);
# line 226 "Semantic.puma"
CloseScope ();
}
return;
}
case kBODY_NODE:
# line 239 "Semantic.puma"
{
# line 240 "Semantic.puma"
BodyCheck (t, current_unit);
# line 241 "Semantic.puma"
allocate_top = 0;
# line 242 "Semantic.puma"
Nesting = 0;
# line 243 "Semantic.puma"
SemDeclarations (t->BODY_NODE.DECLS, current_unit);
# line 244 "Semantic.puma"
Semantic (t->BODY_NODE.STATS);
# line 246 "Semantic.puma"
DeallocateCheck ();
# line 247 "Semantic.puma"
if (IsPure) SemPureCheck (t);
}
return;
case kACF_LIST:
# line 256 "Semantic.puma"
{
# line 257 "Semantic.puma"
set_protocol_stmt (t->ACF_LIST.Elem);
# line 258 "Semantic.puma"
Semantic (t->ACF_LIST.Elem);
# line 259 "Semantic.puma"
Semantic (t->ACF_LIST.Next);
}
return;
case kACF_EMPTY:
# line 262 "Semantic.puma"
return;
case kACF_DUMMY:
# line 265 "Semantic.puma"
return;
case kACF_BASIC:
# line 268 "Semantic.puma"
{
# line 269 "Semantic.puma"
Semantic (t->ACF_BASIC.BASIC_STMT);
}
return;
case kACF_IF:
# line 272 "Semantic.puma"
{
int rank;
{
# line 274 "Semantic.puma"
# line 276 "Semantic.puma"
SemExp (t->ACF_IF.IF_EXP, & rank);
# line 277 "Semantic.puma"
if (rank != 0)
error_protocol ("Rank of EXP > 0 in IF");
# line 280 "Semantic.puma"
Semantic (t->ACF_IF.THEN_PART);
# line 281 "Semantic.puma"
Semantic (t->ACF_IF.ELSE_PART);
}
return;
}
case kACF_WHERE:
# line 284 "Semantic.puma"
{
int whererank;
{
# line 286 "Semantic.puma"
# line 288 "Semantic.puma"
SemExp (t->ACF_WHERE.WHERE_EXP, & whererank);
# line 290 "Semantic.puma"
if (whererank > 0)
{ SemanticWhere (t->ACF_WHERE.TRUE_PART, whererank);
SemanticWhere (t->ACF_WHERE.FALSE_PART, whererank);
}
else
error_protocol ("Illegal Rank of Expression in WHERE");
}
return;
}
case kACF_CASE:
# line 299 "Semantic.puma"
{
int rank;
{
# line 301 "Semantic.puma"
# line 303 "Semantic.puma"
SemExp (t->ACF_CASE.CASE_EXP, & rank);
# line 304 "Semantic.puma"
if (rank != 0)
error_protocol ("Illegal Rank of Expression in CASE");
# line 307 "Semantic.puma"
Semantic (t->ACF_CASE.CASE_ALTS);
# line 308 "Semantic.puma"
Semantic (t->ACF_CASE.CASE_OTHERWISE);
}
return;
}
case kSELECTED_ACF_LIST:
# line 311 "Semantic.puma"
{
# line 312 "Semantic.puma"
Semantic (t->SELECTED_ACF_LIST.Elem);
# line 313 "Semantic.puma"
Semantic (t->SELECTED_ACF_LIST.Next);
}
return;
case kSELECTED_ACF_EMPTY:
# line 316 "Semantic.puma"
return;
case kSELECTED_ACF_NODE:
# line 319 "Semantic.puma"
{
# line 321 "Semantic.puma"
SemExpList (t->SELECTED_ACF_NODE.SELECT_LIST);
# line 322 "Semantic.puma"
Semantic (t->SELECTED_ACF_NODE.SELECT_ACFS);
}
return;
case kACF_WHILE:
# line 325 "Semantic.puma"
{
int rank;
{
# line 327 "Semantic.puma"
# line 329 "Semantic.puma"
SemExp (t->ACF_WHILE.WHILE_EXP, & rank);
# line 331 "Semantic.puma"
if (rank != 0)
error_protocol ("Rank of EXP > 0 in WHILE");
# line 334 "Semantic.puma"
Semantic (t->ACF_WHILE.WHILE_BODY);
}
return;
}
case kACF_DOALL:
# line 337 "Semantic.puma"
{
int rank;
{
# line 339 "Semantic.puma"
# line 343 "Semantic.puma"
SemExp (t->ACF_DOALL.DOALL_ID, & rank);
# line 344 "Semantic.puma"
SemExp (t->ACF_DOALL.DOALL_RANGE, & rank);
# line 346 "Semantic.puma"
if (Nesting >= MAXLoops)
simple_error_protocol ("to deep do/doall loop nesting");
else
{ Nest [Nesting] = t;
Nesting += 1;
Semantic (t->ACF_DOALL.DOALL_BODY);
Nesting -= 1;
}
}
return;
}
case kACF_DOLOCAL:
# line 357 "Semantic.puma"
{
int rank;
{
# line 359 "Semantic.puma"
# line 361 "Semantic.puma"
SemExp (t->ACF_DOLOCAL.DOLOCAL_ID, & rank);
# line 362 "Semantic.puma"
SemExp (t->ACF_DOLOCAL.DOLOCAL_RANGE, & rank);
# line 364 "Semantic.puma"
if (Nesting >= MAXLoops)
simple_error_protocol ("to deep do/forall loop nesting");
else
{ Nest [Nesting] = t;
Nesting += 1;
Semantic (t->ACF_DOLOCAL.DOLOCAL_BODY);
Nesting -= 1;
}
}
return;
}
case kACF_FORALL:
# line 380 "Semantic.puma"
{
int rank;
{
# line 382 "Semantic.puma"
# line 384 "Semantic.puma"
SemExp (t->ACF_FORALL.FORALL_ID, & rank);
# line 385 "Semantic.puma"
SemExp (t->ACF_FORALL.FORALL_RANGE, & rank);
# line 387 "Semantic.puma"
if (Nesting >= MAXLoops)
simple_error_protocol ("to deep do/forall loop nesting");
else
{ Nest [Nesting] = t;
Nesting += 1;
SemanticForall (t->ACF_FORALL.FORALL_BODY);
Nesting -= 1;
}
}
return;
}
case kACF_DO:
# line 403 "Semantic.puma"
{
int rank;
{
# line 405 "Semantic.puma"
# line 407 "Semantic.puma"
SemExp (t->ACF_DO.DO_ID, & rank);
# line 408 "Semantic.puma"
SemExp (t->ACF_DO.DO_RANGE, & rank);
# line 410 "Semantic.puma"
if (Nesting >= MAXLoops)
simple_error_protocol ("to deep do/forall loop nesting");
else
{ Nest [Nesting] = t;
Nesting += 1;
Semantic (t->ACF_DO.DO_BODY);
Nesting -= 1;
}
}
return;
}
case kACF_ENTRY:
# line 421 "Semantic.puma"
{
# line 422 "Semantic.puma"
tree_error_protocol ("ENTRY not supported", t);
}
return;
case kASSIGN_STMT:
# line 425 "Semantic.puma"
{
int rank_lhs;
int rank_rhs;
{
# line 427 "Semantic.puma"
# line 428 "Semantic.puma"
# line 430 "Semantic.puma"
SemExp (t->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
# line 431 "Semantic.puma"
SemExp (t->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
# line 433 "Semantic.puma"
CheckLHSVar (t->ASSIGN_STMT.ASSIGN_VAR);
# line 435 "Semantic.puma"
if (rank_rhs > 0)
{ if (rank_lhs != rank_rhs)
{ error_protocol ("LHS and RHS have different rank");
sprintf (string, "Rank of LHS = %d : " , rank_lhs);
tree_protocol (string, t->ASSIGN_STMT.ASSIGN_VAR);
sprintf (string, "Rank of RHS = %d : " , rank_rhs);
tree_protocol (string, t->ASSIGN_STMT.ASSIGN_EXP);
}
}
}
return;
}
case kPTR_ASSIGN_STMT:
# line 447 "Semantic.puma"
{
# line 448 "Semantic.puma"
tree_error_protocol ("pointer assignment not supported", t);
}
return;
case kLABEL_ASSIGN_STMT:
# line 451 "Semantic.puma"
{
int rank;
{
# line 453 "Semantic.puma"
# line 455 "Semantic.puma"
SemExp (t->LABEL_ASSIGN_STMT.LABEL_VAR, & rank);
# line 456 "Semantic.puma"
if (rank != 0)
error_protocol ("variable in LABEL ASSIGN must have rank 0");
}
return;
}
case kFORMAT_STMT:
# line 461 "Semantic.puma"
return;
case kIO_STMT:
# line 464 "Semantic.puma"
{
# line 465 "Semantic.puma"
SemanticIO (t);
}
return;
case kCALL_STMT:
# line 468 "Semantic.puma"
{
# line 470 "Semantic.puma"
if (! (t->CALL_STMT.CALL_ID->PROC_OBJ.Object == GetDeclEntry (t->CALL_STMT.CALL_ID->PROC_OBJ.Ident, GetIntrinsicEntries ()))) goto yyL31;
{
# line 473 "Semantic.puma"
AnalIntrinsicSubroutine (t->CALL_STMT.CALL_ID->PROC_OBJ.Ident, t->CALL_STMT.CALL_PARAMS);
}
}
return;
yyL31:;
# line 476 "Semantic.puma"
{
# line 480 "Semantic.puma"
SemanticCall (t, t->CALL_STMT.CALL_ID->PROC_OBJ.Object);
}
return;
case kGOTO_STMT:
# line 483 "Semantic.puma"
return;
case kASS_GOTO_STMT:
# line 486 "Semantic.puma"
{
int rank;
{
# line 488 "Semantic.puma"
# line 490 "Semantic.puma"
SemExp (t->ASS_GOTO_STMT.GOTO_VAR, & rank);
# line 492 "Semantic.puma"
if (rank != 0)
error_protocol ("Illegal rank for expression in ASSIGNED GOTO");
}
return;
}
case kCOMP_GOTO_STMT:
# line 498 "Semantic.puma"
{
int rank;
{
# line 500 "Semantic.puma"
# line 502 "Semantic.puma"
SemExp (t->COMP_GOTO_STMT.GOTO_EXP, & rank);
# line 504 "Semantic.puma"
if (rank != 0)
error_protocol ("Illegal rank for expression in COMPUTED GOTO");
}
return;
}
case kCOMP_IF_STMT:
# line 510 "Semantic.puma"
{
int rank;
{
# line 512 "Semantic.puma"
# line 514 "Semantic.puma"
SemExp (t->COMP_IF_STMT.IF_EXP, & rank);
# line 516 "Semantic.puma"
if (rank != 0)
error_protocol ("Illegal rank for expression in COMPUTED IF");
}
return;
}
case kSTOP_STMT:
# line 521 "Semantic.puma"
return;
case kPAUSE_STMT:
# line 524 "Semantic.puma"
return;
case kEXIT_STMT:
# line 527 "Semantic.puma"
return;
case kCYCLE_STMT:
# line 530 "Semantic.puma"
return;
case kRETURN_STMT:
# line 533 "Semantic.puma"
{
# line 534 "Semantic.puma"
if (current_unit->Kind == kPROGRAM_DECL)
error_protocol ("RETURN not permitted in main program");
}
return;
case kREDUCE_STMT:
# line 539 "Semantic.puma"
{
bool parloop;
int i;
{
# line 541 "Semantic.puma"
# line 541 "Semantic.puma"
# line 543 "Semantic.puma"
parloop = false;
for (i=0; i<Nesting; i++)
parloop = (parloop || (Nest[i]->Kind == kACF_DOLOCAL));
if (!parloop)
error_protocol ("REDUCE only in parallel loops allowed");
else
{
if ( (t->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident != MakeIdent("MINVAL",6))
&& (t->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident != MakeIdent("MAXVAL",6))
&& (TreeListLength (t->REDUCE_STMT.RED_PARAMS) > 2 ) )
error_protocol ("REDUCE with too many parameters");
CheckReduceParams (t->REDUCE_STMT.RED_PARAMS);
}
}
return;
}
case kALLOCATE_STMT:
# line 560 "Semantic.puma"
{
# line 562 "Semantic.puma"
CheckAllocateParams (t->ALLOCATE_STMT.PARAMS);
}
return;
case kDEALLOCATE_STMT:
# line 565 "Semantic.puma"
{
# line 567 "Semantic.puma"
CheckDeallocateParams (t->DEALLOCATE_STMT.PARAMS);
}
return;
case kNULLIFY_STMT:
# line 570 "Semantic.puma"
{
# line 571 "Semantic.puma"
tree_error_protocol ("NULLIFY not supported", t);
}
return;
case kALIGN_STMT:
# line 574 "Semantic.puma"
{
# line 575 "Semantic.puma"
tree_error_protocol ("dynamic alignment not supported", t);
}
return;
case kDISTRIBUTE_STMT:
# line 578 "Semantic.puma"
{
# line 579 "Semantic.puma"
tree_error_protocol ("dynamic distribution not supported", t);
}
return;
}
# line 582 "Semantic.puma"
{
# line 583 "Semantic.puma"
error_protocol ("unknown tree node Semantic");
printf ("Unknown Tree Node");
WriteTree (stdout, t);
kill_in_protocol ();
}
return;
;
}
static void BodyCheck
# if defined __STDC__ | defined __cplusplus
(register tTree body, register tTree unit)
# else
(body, unit)
register tTree body;
register tTree unit;
# endif
{
if (body->Kind == kBODY_NODE) {
if (body->BODY_NODE.STATS->Kind == kACF_EMPTY) {
if (unit->Kind == kMODULE_DECL) {
# line 603 "Semantic.puma"
return;
}
if (body->BODY_NODE.INTERNALS->Kind == kDECL_EMPTY) {
if (unit->Kind == kBLOCK_DATA_DECL) {
# line 610 "Semantic.puma"
return;
}
}
}
if (unit->Kind == kMODULE_DECL) {
# line 606 "Semantic.puma"
{
# line 607 "Semantic.puma"
simple_error_protocol ("statements in MODULE not allowed");
}
return;
}
if (body->BODY_NODE.INTERNALS->Kind == kDECL_EMPTY) {
if (unit->Kind == kBLOCK_DATA_DECL) {
# line 613 "Semantic.puma"
{
# line 614 "Semantic.puma"
simple_error_protocol ("statements in BLOCK_DATA not allowed");
}
return;
}
}
if (unit->Kind == kBLOCK_DATA_DECL) {
# line 617 "Semantic.puma"
{
# line 618 "Semantic.puma"
simple_error_protocol ("internal subroutines in BLOCK_DATA not allowed");
}
return;
}
}
;
}
static void SemanticWhere
# if defined __STDC__ | defined __cplusplus
(register tTree t, register int whererank)
# else
(t, whererank)
register tTree t;
register int whererank;
# endif
{
# line 632 "Semantic.puma"
char string[50];
if (t->Kind == kACF_LIST) {
# line 636 "Semantic.puma"
{
# line 637 "Semantic.puma"
set_protocol_stmt (t->ACF_LIST.Elem);
# line 638 "Semantic.puma"
SemanticWhere (t->ACF_LIST.Elem, whererank);
# line 639 "Semantic.puma"
SemanticWhere (t->ACF_LIST.Next, whererank);
}
return;
}
if (t->Kind == kACF_EMPTY) {
# line 642 "Semantic.puma"
return;
}
if (t->Kind == kACF_BASIC) {
if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
# line 645 "Semantic.puma"
{
int rank_lhs;
int rank_rhs;
{
# line 647 "Semantic.puma"
# line 648 "Semantic.puma"
# line 650 "Semantic.puma"
SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
# line 651 "Semantic.puma"
SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
# line 653 "Semantic.puma"
if (rank_lhs != whererank)
{ error_protocol ("Assignment in WHERE has wrong rank");
sprintf (string, "Rank of LHS = %d : " , rank_lhs);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
sprintf (string, "Rank of WHERE exp = %d : " , whererank);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
}
if (rank_rhs > 0)
{ if (rank_lhs != rank_rhs)
{ error_protocol ("LHS and RHS have different rank");
sprintf (string, "Rank of LHS = %d : " , rank_lhs);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
sprintf (string, "Rank of RHS = %d : " , rank_rhs);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
}
}
}
return;
}
}
}
if (t->Kind == kACF_WHERE) {
# line 672 "Semantic.puma"
{
# line 673 "Semantic.puma"
error_protocol ("Nesting of WHERE not allowed until now");
}
return;
}
# line 676 "Semantic.puma"
{
# line 677 "Semantic.puma"
error_protocol ("Illegal Statement in WHERE");
}
return;
;
}
static void SemanticForall
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
# line 691 "Semantic.puma"
char string[50];
int i;
if (t->Kind == kACF_LIST) {
# line 696 "Semantic.puma"
{
# line 697 "Semantic.puma"
set_protocol_stmt (t->ACF_LIST.Elem);
# line 698 "Semantic.puma"
SemanticForall (t->ACF_LIST.Elem);
# line 699 "Semantic.puma"
SemanticForall (t->ACF_LIST.Next);
}
return;
}
if (t->Kind == kACF_EMPTY) {
# line 702 "Semantic.puma"
return;
}
if (t->Kind == kACF_BASIC) {
if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
# line 705 "Semantic.puma"
{
int rank_lhs;
int rank_rhs;
{
# line 707 "Semantic.puma"
# line 708 "Semantic.puma"
# line 710 "Semantic.puma"
SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
# line 711 "Semantic.puma"
SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
# line 713 "Semantic.puma"
if (rank_rhs > 0)
{ if (rank_lhs != rank_rhs)
{ error_protocol ("LHS and RHS have different rank");
sprintf (string, "Rank of LHS = %d : " , rank_lhs);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
sprintf (string, "Rank of RHS = %d : " , rank_rhs);
tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
}
}
for (i=0; i<Nesting; i++)
ForallLoopVarCheck (Nest[i], t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
}
return;
}
}
}
if (t->Kind == kACF_FORALL) {
# line 730 "Semantic.puma"
{
int rank;
{
# line 732 "Semantic.puma"
# line 734 "Semantic.puma"
SemExp (t->ACF_FORALL.FORALL_ID, & rank);
# line 735 "Semantic.puma"
SemExp (t->ACF_FORALL.FORALL_RANGE, & rank);
# line 737 "Semantic.puma"
if (Nesting >= MAXLoops)
simple_error_protocol ("to deep do/forall loop nesting");
else
{ Nest [Nesting] = t;
Nesting += 1;
SemanticForall (t->ACF_FORALL.FORALL_BODY);
Nesting -= 1;
}
}
return;
}
}
if (t->Kind == kACF_WHERE) {
# line 749 "Semantic.puma"
{
int rank;
{
# line 751 "Semantic.puma"
# line 753 "Semantic.puma"
SemExp (t->ACF_WHERE.WHERE_EXP, & rank);
# line 755 "Semantic.puma"
SemanticForall (t->ACF_WHERE.TRUE_PART);
# line 756 "Semantic.puma"
SemanticForall (t->ACF_WHERE.FALSE_PART);
}
return;
}
}
if (t->Kind == kACF_IF) {
# line 759 "Semantic.puma"
{
int rank;
{
# line 761 "Semantic.puma"
# line 763 "Semantic.puma"
SemExp (t->ACF_IF.IF_EXP, & rank);
# line 765 "Semantic.puma"
SemanticForall (t->ACF_IF.THEN_PART);
# line 766 "Semantic.puma"
SemanticForall (t->ACF_IF.ELSE_PART);
}
return;
}
}
# line 769 "Semantic.puma"
{
# line 770 "Semantic.puma"
error_protocol ("Illegal Statement in FORALL");
}
return;
;
}
static void ForallLoopVarCheck
# if defined __STDC__ | defined __cplusplus
(register tTree loop, register tTree var)
# else
(loop, var)
register tTree loop;
register tTree var;
# endif
{
if (loop->Kind == kACF_FORALL) {
if (var->Kind == kUSED_VAR) {
# line 786 "Semantic.puma"
{
# line 790 "Semantic.puma"
error_protocol ("Only indexed variable in lhs of FORALL assignments");
}
return;
}
if (loop->ACF_FORALL.FORALL_ID->Kind == kLOOP_VAR) {
if (var->Kind == kINDEXED_VAR) {
# line 793 "Semantic.puma"
{
# line 798 "Semantic.puma"
if (IsVarInExp (loop->ACF_FORALL.FORALL_ID->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident, var->INDEXED_VAR.IND_EXPS) == 0)
{ error_protocol ("loop index appears not in lhs in FORALL");
tree_protocol ("assignment variable is ", var);
tree_protocol ("loop variable is ", loop->ACF_FORALL.FORALL_ID);
}
}
return;
}
}
}
;
}
static void SemanticIO
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
# line 814 "Semantic.puma"
char string[256];
tObject Obj;
int dist;
if (t->Kind == kIO_STMT) {
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("PRINT", 5))) {
# line 820 "Semantic.puma"
{
# line 821 "Semantic.puma"
SemParamList (t->IO_STMT.IO_ITEMS);
}
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("READ", 4))) {
# line 824 "Semantic.puma"
{
# line 825 "Semantic.puma"
SemParamList (t->IO_STMT.IO_ITEMS);
# line 826 "Semantic.puma"
SemReadParams (t->IO_STMT.IO_ITEMS);
}
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("WRITE", 5))) {
# line 829 "Semantic.puma"
{
# line 830 "Semantic.puma"
SemParamList (t->IO_STMT.IO_ITEMS);
}
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("OPEN", 4))) {
# line 833 "Semantic.puma"
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("CLOSE", 5))) {
# line 836 "Semantic.puma"
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("REWIND", 6))) {
# line 839 "Semantic.puma"
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("BACKSPACE", 9))) {
# line 842 "Semantic.puma"
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("INQUIRE", 7))) {
# line 845 "Semantic.puma"
return;
}
if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("ENDFILE", 7))) {
# line 848 "Semantic.puma"
return;
}
# line 851 "Semantic.puma"
{
# line 852 "Semantic.puma"
GetString (t->IO_STMT.ID->PROC_OBJ.Ident, string);
# line 853 "Semantic.puma"
printf ("%s in I/O\n",string);
error_protocol ("Unknown name in I/O");
}
return;
}
if (t->Kind == kBTP_LIST) {
# line 858 "Semantic.puma"
{
# line 859 "Semantic.puma"
SemanticIO (t->BTP_LIST.Elem);
# line 860 "Semantic.puma"
SemanticIO (t->BTP_LIST.Next);
}
return;
}
if (t->Kind == kBTP_EMPTY) {
# line 863 "Semantic.puma"
return;
}
if (t->Kind == kVAR_PARAM) {
# line 866 "Semantic.puma"
return;
}
# line 869 "Semantic.puma"
{
# line 870 "Semantic.puma"
printf ("Unknown Tree Node for Semantic Analysis of IO \n");
# line 871 "Semantic.puma"
WriteTreeNode (stdout, t);
# line 872 "Semantic.puma"
kill_in_protocol ();
}
return;
;
}
static void SemReadParams
# if defined __STDC__ | defined __cplusplus
(register tTree items)
# else
(items)
register tTree items;
# endif
{
if (items->Kind == kBTP_LIST) {
# line 883 "Semantic.puma"
{
# line 884 "Semantic.puma"
SemReadParams (items->BTP_LIST.Elem);
# line 885 "Semantic.puma"
SemReadParams (items->BTP_LIST.Next);
}
return;
}
if (items->Kind == kBTP_EMPTY) {
# line 888 "Semantic.puma"
return;
}
if (items->Kind == kVAR_PARAM) {
if (items->VAR_PARAM.V->Kind == kUSED_VAR) {
# line 891 "Semantic.puma"
return;
}
if (items->VAR_PARAM.V->Kind == kINDEXED_VAR) {
# line 895 "Semantic.puma"
return;
}
if (items->VAR_PARAM.V->Kind == kADDR) {
if (items->VAR_PARAM.V->ADDR.E->Kind == kDO_EXP) {
# line 899 "Semantic.puma"
{
# line 901 "Semantic.puma"
items->VAR_PARAM.V = MakeDoVar (items->VAR_PARAM.V->ADDR.E);
}
return;
}
# line 904 "Semantic.puma"
{
# line 905 "Semantic.puma"
error_protocol ("Illegal READ parameter");
# line 906 "Semantic.puma"
tree_protocol ("Parameter is ", items);
}
return;
}
}
# line 909 "Semantic.puma"
{
# line 910 "Semantic.puma"
error_protocol ("Cannot handle this READ parameter");
# line 911 "Semantic.puma"
tree_protocol ("Parameter is ", items);
}
return;
;
}
static tTree MakeDoVar
# if defined __STDC__ | defined __cplusplus
(register tTree DoExp)
# else
(DoExp)
register tTree DoExp;
# endif
{
if (DoExp->Kind == kDO_EXP) {
# line 916 "Semantic.puma"
return mDO_VAR (DoExp->DO_EXP.DO_ID, DoExp->DO_EXP.RANGE, MakeDoVar (DoExp->DO_EXP.BODY));
}
if (DoExp->Kind == kBTE_LIST) {
if (DoExp->BTE_LIST.Elem->Kind == kVAR_EXP) {
# line 920 "Semantic.puma"
return mBTV_LIST (DoExp->BTE_LIST.Elem->VAR_EXP.V, MakeDoVar (DoExp->BTE_LIST.Next));
}
if (DoExp->BTE_LIST.Elem->Kind == kDO_EXP) {
# line 925 "Semantic.puma"
return mBTV_LIST (MakeDoVar (DoExp->BTE_LIST.Elem), MakeDoVar (DoExp->BTE_LIST.Next));
}
# line 929 "Semantic.puma"
{
# line 931 "Semantic.puma"
error_protocol ("Illegal READ parameter in DO_EXP");
# line 932 "Semantic.puma"
tree_protocol ("Expression is : ", DoExp->BTE_LIST.Elem);
}
return mBTV_LIST (mADDR (DoExp->BTE_LIST.Elem), MakeDoVar (DoExp->BTE_LIST.Next));
}
if (DoExp->Kind == kBTE_EMPTY) {
# line 936 "Semantic.puma"
return mBTV_EMPTY ();
}
yyAbort ("MakeDoVar");
}
void SemanticCall
# if defined __STDC__ | defined __cplusplus
(register tTree t, register tDefinitions p)
# else
(t, p)
register tTree t;
register tDefinitions p;
# endif
{
if (t->Kind == kCALL_STMT) {
if (Definitions_IsType (t->CALL_STMT.CALL_ID->PROC_OBJ.Object, kObject)) {
if (p->Kind == kProcObject) {
if (p->ProcObject.decl->Kind == kPROC_DECL) {
# line 954 "Semantic.puma"
{
# line 957 "Semantic.puma"
if (TreeListLength (t->CALL_STMT.CALL_PARAMS) != TreeListLength (p->ProcObject.decl->PROC_DECL.FORMALS))
{ error_protocol ("Number of parameters mismatch");
tree_protocol ("formals : ", p->ProcObject.decl->PROC_DECL.FORMALS);
}
else
SemanticCallParams (t->CALL_STMT.CALL_PARAMS, p->ProcObject.decl->PROC_DECL.FORMALS, p->ProcObject.Declarations);
}
return;
}
if (p->ProcObject.decl->Kind == kPROC_PARAM_DECL) {
# line 973 "Semantic.puma"
{
# line 976 "Semantic.puma"
SemParamList (t->CALL_STMT.CALL_PARAMS);
}
return;
}
if (p->ProcObject.decl->Kind == kEXT_PROC_DECL) {
# line 985 "Semantic.puma"
{
# line 988 "Semantic.puma"
SemParamList (t->CALL_STMT.CALL_PARAMS);
}
return;
}
}
}
}
if (t->Kind == kFUNC_CALL_EXP) {
if (Definitions_IsType (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Object, kObject)) {
if (p->Kind == kFuncObject) {
if (p->FuncObject.decl->Kind == kFUNC_DECL) {
# line 997 "Semantic.puma"
{
# line 1000 "Semantic.puma"
if (TreeListLength (t->FUNC_CALL_EXP.FUNC_PARAMS) != TreeListLength (p->FuncObject.decl->FUNC_DECL.FORMALS))
{ error_protocol ("Number of parameters mismatch");
tree_protocol ("formals : ", p->FuncObject.decl->FUNC_DECL.FORMALS);
}
else
SemanticCallParams (t->FUNC_CALL_EXP.FUNC_PARAMS, p->FuncObject.decl->FUNC_DECL.FORMALS, p->FuncObject.Declarations);
}
return;
}
if (p->FuncObject.decl->Kind == kSTMT_FUNC_DECL) {
# line 1016 "Semantic.puma"
{
# line 1019 "Semantic.puma"
if (TreeListLength (t->FUNC_CALL_EXP.FUNC_PARAMS) != TreeListLength (p->FuncObject.decl->STMT_FUNC_DECL.FORMALS))
{ error_protocol ("Number of parameters mismatch");
tree_protocol ("formals : ", p->FuncObject.decl->STMT_FUNC_DECL.FORMALS);
}
else
SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
}
return;
}
if (p->FuncObject.decl->Kind == kEXT_FUNC_DECL) {
# line 1035 "Semantic.puma"
{
# line 1037 "Semantic.puma"
SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
}
return;
}
if (p->FuncObject.decl->Kind == kFUNC_PARAM_DECL) {
# line 1046 "Semantic.puma"
{
# line 1048 "Semantic.puma"
SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
}
return;
}
}
}
}
# line 1051 "Semantic.puma"
{
# line 1052 "Semantic.puma"
printf ("Illegal Tree in SemanticCall\n");
# line 1053 "Semantic.puma"
FileUnparse (stdout, t);
# line 1054 "Semantic.puma"
kill_in_protocol ();
}
return;
;
}
static void SemanticCallParams
# if defined __STDC__ | defined __cplusplus
(register tTree a, register tTree f, register tDefinitions d)
# else
(a, f, d)
register tTree a;
register tTree f;
register tDefinitions d;
# endif
{
if (a->Kind == kBTP_LIST) {
if (f->Kind == kDECL_LIST) {
if (f->DECL_LIST.Elem->Kind == kVAR_PARAM_DECL) {
# line 1065 "Semantic.puma"
{
tDefinitions Obj;
{
# line 1068 "Semantic.puma"
# line 1070 "Semantic.puma"
Obj = GetDeclEntry (f->DECL_LIST.Elem->VAR_PARAM_DECL.Name, d);
# line 1073 "Semantic.puma"
SemanticMatchParam (a->BTP_LIST.Elem, Obj);
# line 1074 "Semantic.puma"
SemanticCallParams (a->BTP_LIST.Next, f->DECL_LIST.Next, d);
}
return;
}
}
}
}
if (a->Kind == kBTP_EMPTY) {
if (f->Kind == kDECL_EMPTY) {
# line 1077 "Semantic.puma"
return;
}
}
# line 1080 "Semantic.puma"
{
# line 1081 "Semantic.puma"
printf ("Cannot compare actual and formal parameters");
# line 1082 "Semantic.puma"
kill_in_protocol ();
}
return;
;
}
static void SemanticMatchParam
# if defined __STDC__ | defined __cplusplus
(register tTree actual, register tDefinitions formal)
# else
(actual, formal)
register tTree actual;
register tDefinitions formal;
# endif
{
# line 1093 "Semantic.puma"
char msg[100];
if (actual->Kind == kVAR_PARAM) {
# line 1097 "Semantic.puma"
{
int rank;
{
# line 1099 "Semantic.puma"
# line 1101 "Semantic.puma"
SemExp (actual->VAR_PARAM.V, & rank);
# line 1103 "Semantic.puma"
if (VarRank (formal) != rank)
{
if (TreeDistribution (actual) > 0)
{ error_protocol ("rank mismatch of actual and formal parameter");
sprintf (msg, "Rank of actual parameter = %d : ", rank);
tree_protocol (msg, actual);
sprintf (msg, "Rank of formal parameter = %d : ", VarRank(formal));
obj_protocol (msg, formal);
}
else
{ sprintf (msg, "Rank mismatch of actual parameter = %d : ", rank);
tree_warning_protocol (msg, actual);
sprintf (msg, "Rank of formal parameter = %d : ", VarRank(formal));
simple_warning_protocol (msg);
}
}
}
return;
}
}
if (actual->Kind == kFUNC_PARAM) {
# line 1122 "Semantic.puma"
return;
}
if (actual->Kind == kPROC_PARAM) {
# line 1125 "Semantic.puma"
return;
}
# line 1128 "Semantic.puma"
{
# line 1129 "Semantic.puma"
printf ("SemanticMatchParam fails\n");
# line 1130 "Semantic.puma"
FileUnparse (stdout, actual);
# line 1131 "Semantic.puma"
kill_in_protocol ();
}
return;
;
}
static void AnalIntrinsicSubroutine
# if defined __STDC__ | defined __cplusplus
(register tIdent name, register tTree params)
# else
(name, params)
register tIdent name;
register tTree params;
# endif
{
if (equaltIdent (name, MakeIdent ("CMF_RANDOM", 10))) {
# line 1142 "Semantic.puma"
{
# line 1143 "Semantic.puma"
CheckRandomParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("CMF_RANDOMIZE", 13))) {
# line 1148 "Semantic.puma"
{
# line 1150 "Semantic.puma"
CheckRandomizeParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("WALLTIME", 8))) {
# line 1153 "Semantic.puma"
{
# line 1155 "Semantic.puma"
CheckWalltimeParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("CM_TIMER_CLEAR", 14))) {
# line 1158 "Semantic.puma"
{
# line 1159 "Semantic.puma"
CheckTimerParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("CM_TIMER_PRINT", 14))) {
# line 1162 "Semantic.puma"
{
# line 1163 "Semantic.puma"
CheckTimerParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("CM_TIMER_START", 14))) {
# line 1166 "Semantic.puma"
{
# line 1167 "Semantic.puma"
CheckTimerParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("CM_TIMER_STOP", 13))) {
# line 1170 "Semantic.puma"
{
# line 1171 "Semantic.puma"
CheckTimerParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("GLOBAL_GET", 10))) {
# line 1174 "Semantic.puma"
{
# line 1176 "Semantic.puma"
CheckGlobalGetParams (params);
}
return;
}
if (equaltIdent (name, MakeIdent ("GLOBAL_SEND", 11))) {
# line 1179 "Semantic.puma"
{
# line 1181 "Semantic.puma"
CheckGlobalSendParams (params);
}
return;
}
# line 1184 "Semantic.puma"
{
# line 1185 "Semantic.puma"
error_protocol ("Unknown intrinsic Subroutine in Analysis");
}
return;
;
}
static void CheckReduceParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_EMPTY) {
# line 1198 "Semantic.puma"
return;
}
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Next->Kind == kBTP_LIST) {
# line 1201 "Semantic.puma"
{
# line 1202 "Semantic.puma"
if (!IsVarParameter (t->BTP_LIST.Elem))
{ error_protocol ("Variable required for reduce");
tree_protocol ("This parameter is not a variable : ", t->BTP_LIST.Elem);
}
# line 1207 "Semantic.puma"
CheckReduceParams (t->BTP_LIST.Next->BTP_LIST.Next);
}
return;
}
}
# line 1210 "Semantic.puma"
{
# line 1211 "Semantic.puma"
error_protocol ("Illegal parameter list for REDUCE");
# line 1212 "Semantic.puma"
print_protocol ("REDUCE (f, var, exp, var, exp, ..., var, exp)");
}
return;
;
}
static void CheckRandomParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_EMPTY) {
# line 1226 "Semantic.puma"
{
# line 1227 "Semantic.puma"
error_protocol ("CMF_RANDOM needs on or two parameters");
}
return;
}
if (t->Kind == kBTP_LIST) {
# line 1230 "Semantic.puma"
{
# line 1231 "Semantic.puma"
if (! ((! IsVarParameter (t->BTP_LIST.Elem)))) goto yyL2;
{
# line 1232 "Semantic.puma"
error_protocol ("CMF_RANDOM: first parameter must be variable");
}
}
return;
yyL2:;
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
# line 1235 "Semantic.puma"
{
# line 1236 "Semantic.puma"
CheckRandomTypes (TreeType (t->BTP_LIST.Elem->VAR_PARAM.V), NoTree);
}
return;
}
if (t->BTP_LIST.Next->Kind == kBTP_LIST) {
if (t->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
# line 1239 "Semantic.puma"
{
int rank;
{
# line 1241 "Semantic.puma"
# line 1243 "Semantic.puma"
SemExp (t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V, & rank);
# line 1245 "Semantic.puma"
if (rank != 0)
error_protocol ("Second Parameter of CMF_RANDOM must be a scalar");
# line 1248 "Semantic.puma"
CheckRandomTypes (TreeType (t->BTP_LIST.Elem->VAR_PARAM.V), t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V);
}
return;
}
}
}
}
}
}
# line 1251 "Semantic.puma"
{
# line 1252 "Semantic.puma"
error_protocol ("Illegal parameter list for CMF_RANDOM");
}
return;
;
}
static void CheckRandomTypes
# if defined __STDC__ | defined __cplusplus
(register tTree type, register tTree limit)
# else
(type, limit)
register tTree type;
register tTree limit;
# endif
{
if (type->Kind == kREAL_TYPE) {
if (equalint (type->REAL_TYPE.size, 4)) {
# line 1258 "Semantic.puma"
return;
}
if (equalint (type->REAL_TYPE.size, 8)) {
# line 1261 "Semantic.puma"
return;
}
# line 1264 "Semantic.puma"
{
# line 1265 "Semantic.puma"
error_protocol ("CMF_RANDOM: real, but not real*4 or real*8");
}
return;
}
if (type->Kind == kINTEGER_TYPE) {
if (equalint (type->INTEGER_TYPE.size, 4)) {
# line 1268 "Semantic.puma"
{
# line 1269 "Semantic.puma"
if (limit == NoTree)
error_protocol ("CMF_RANDOM: integer array requires limit parameter");
}
return;
}
# line 1274 "Semantic.puma"
{
# line 1275 "Semantic.puma"
error_protocol ("CMF_RANDOM: integer, but not integer*4");
}
return;
}
# line 1278 "Semantic.puma"
{
# line 1279 "Semantic.puma"
error_protocol ("CMF_RANDOM: first parameter must be real or integer");
}
return;
;
}
static void CheckRandomizeParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
# line 1290 "Semantic.puma"
{
int rank;
{
# line 1292 "Semantic.puma"
# line 1294 "Semantic.puma"
SemExp (t->BTP_LIST.Elem, & rank);
# line 1296 "Semantic.puma"
if (rank != 0)
error_protocol ("Randomize Parameter must be a scalar");
}
return;
}
}
}
}
# line 1301 "Semantic.puma"
{
# line 1302 "Semantic.puma"
error_protocol ("CMF_RANDOMIZE requires one integer parameter");
}
return;
;
}
static void CheckWalltimeParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
# line 1313 "Semantic.puma"
{
int rank;
tTree type;
{
# line 1315 "Semantic.puma"
# line 1316 "Semantic.puma"
# line 1318 "Semantic.puma"
if (!IsVarParameter (t->BTP_LIST.Elem))
error_protocol ("WALLTIME: requires REAL*4 variable");
else
{
type = TreeType (t->BTP_LIST.Elem->VAR_PARAM.V);
if (type->Kind != kREAL_TYPE)
error_protocol ("walltime: parameter must be REAL");
else if (type->REAL_TYPE.size != 4)
error_protocol ("walltime: parameter must be REAL*4");
}
SemExp (t->BTP_LIST.Elem, &rank);
if (rank != 0)
error_protocol ("Walltime Parameter must be a scalar");
}
return;
}
}
}
}
# line 1336 "Semantic.puma"
{
# line 1337 "Semantic.puma"
error_protocol ("Walltime: exactly one parameter is required");
}
return;
;
}
static void CheckTimerParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
# line 1348 "Semantic.puma"
{
int rank;
{
# line 1350 "Semantic.puma"
# line 1352 "Semantic.puma"
SemExp (t->BTP_LIST.Elem, & rank);
# line 1354 "Semantic.puma"
if (rank != 0)
error_protocol ("Timer Parameter must be a scalar");
}
return;
}
}
}
}
# line 1359 "Semantic.puma"
{
# line 1360 "Semantic.puma"
error_protocol ("CM_TIMER_... requires one integer parameter");
}
return;
;
}
static void CheckAllocateParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kINDEXED_VAR) {
if (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->Kind == kUSED_VAR) {
# line 1373 "Semantic.puma"
{
# line 1376 "Semantic.puma"
if (TreeRank (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR) != TreeListLength (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_EXPS))
{ error_protocol ("Illegal dimensioned parameter in ALLOCATE");
tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
}
else if (!IsVarAllocatable (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Object))
{ error_protocol ("Not allocatable parameter in ALLOCATE");
tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
}
else if (IsAllocated (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Ident))
{ error_protocol ("Allocatable array has already been allocated");
tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
}
else
{
if (allocate_top == MAX_ALLOCATES)
{ error_protocol ("too many allocates");
kill_in_protocol ();
}
allocate_stack [allocate_top] = t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Ident;
allocate_top += 1;
NormalAllocateParams (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_EXPS);
}
# line 1399 "Semantic.puma"
CheckAllocateParams (t->BTP_LIST.Next);
}
return;
}
}
}
# line 1402 "Semantic.puma"
{
# line 1403 "Semantic.puma"
error_protocol ("Illegal Parameter in ALLOCATE");
tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem);
# line 1406 "Semantic.puma"
CheckAllocateParams (t->BTP_LIST.Next);
}
return;
}
if (t->Kind == kBTP_EMPTY) {
# line 1409 "Semantic.puma"
return;
}
;
}
static void NormalAllocateParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBTE_EMPTY) {
# line 1422 "Semantic.puma"
return;
}
if (t->Kind == kBTE_LIST) {
if (t->BTE_LIST.Elem->Kind == kSLICE_EXP) {
# line 1425 "Semantic.puma"
{
# line 1426 "Semantic.puma"
NormalAllocateParams (t->BTE_LIST.Next);
}
return;
}
# line 1429 "Semantic.puma"
{
# line 1430 "Semantic.puma"
t->BTE_LIST.Elem = mSLICE_EXP (mCONST_EXP(mINT_CONSTANT (1)), t->BTE_LIST.Elem, mDUMMY_EXP());
# line 1431 "Semantic.puma"
NormalAllocateParams (t->BTE_LIST.Next);
}
return;
}
;
}
static void CheckDeallocateParams
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
# line 1442 "Semantic.puma"
bool found;
char s[80], msg[110];
if (t->Kind == kBTP_LIST) {
if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kUSED_VAR) {
# line 1447 "Semantic.puma"
{
# line 1449 "Semantic.puma"
found = false;
while ((!found) && (allocate_top > 0))
{ allocate_top -= 1;
found = (allocate_stack [allocate_top] == t->BTP_LIST.Elem->VAR_PARAM.V->USED_VAR.VARNAME->VAR_OBJ.Ident);
if (!found)
{ GetString (allocate_stack[allocate_top], s);
sprintf (msg, "need at first DEALLOCATE for %s", s);
error_protocol (msg);
}
}
if (!found)
{ GetString (t->BTP_LIST.Elem->VAR_PARAM.V->USED_VAR.VARNAME->VAR_OBJ.Ident, s);
sprintf (msg,"There was no ALLOCATE for %s", s);
error_protocol (msg);
}
# line 1466 "Semantic.puma"
CheckDeallocateParams (t->BTP_LIST.Next);
}
return;
}
}
# line 1469 "Semantic.puma"
{
# line 1470 "Semantic.puma"
error_protocol ("Illegal Parameter in DEALLOCATE");
tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem);
# line 1473 "Semantic.puma"
CheckDeallocateParams (t->BTP_LIST.Next);
}
return;
}
if (t->Kind == kBTP_EMPTY) {
# line 1476 "Semantic.puma"
return;
}
;
}
static bool IsVarParameter
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kVAR_PARAM) {
if (t->VAR_PARAM.V->Kind == kADDR) {
# line 1487 "Semantic.puma"
{
# line 1488 "Semantic.puma"
return false;
}
}
# line 1491 "Semantic.puma"
return true;
}
return false;
}
static void CheckLHSVar
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kINDEXED_VAR) {
# line 1502 "Semantic.puma"
{
# line 1503 "Semantic.puma"
CheckLHSVar (t->INDEXED_VAR.IND_VAR);
}
return;
}
if (t->Kind == kUSED_VAR) {
# line 1506 "Semantic.puma"
{
# line 1507 "Semantic.puma"
if (! (t->USED_VAR.VARNAME->VAR_OBJ.Object == NoObject)) goto yyL2;
{
# line 1508 "Semantic.puma"
error_protocol ("left hand side undefined");
}
}
return;
yyL2:;
if (t->USED_VAR.VARNAME->VAR_OBJ.Object->Kind == kVarObject) {
if (t->USED_VAR.VARNAME->VAR_OBJ.Object->VarObject.Kind->Kind == kVarConstant) {
# line 1511 "Semantic.puma"
{
# line 1512 "Semantic.puma"
error_protocol ("left hand side of assignment must not be parameter");
}
return;
}
}
}
;
}
static void SemPureCheck
# if defined __STDC__ | defined __cplusplus
(register tTree t)
# else
(t)
register tTree t;
# endif
{
if (t->Kind == kBODY_NODE) {
# line 1527 "Semantic.puma"
{
# line 1528 "Semantic.puma"
SemPureCheck (t->BODY_NODE.DECLS);
# line 1529 "Semantic.puma"
SemPureCheck (t->BODY_NODE.STATS);
}
return;
}
if (t->Kind == kDECL_LIST) {
# line 1532 "Semantic.puma"
{
# line 1533 "Semantic.puma"
SemPureCheck (t->DECL_LIST.Elem);
# line 1534 "Semantic.puma"
SemPureCheck (t->DECL_LIST.Next);
}
return;
}
if (t->Kind == kVAR_DECL) {
if (t->VAR_DECL.VAL->Kind == kARRAY_TYPE) {
# line 1537 "Semantic.puma"
{
tDefinitions Obj;
{
# line 1539 "Semantic.puma"
# line 1540 "Semantic.puma"
Obj = GetLocalDecl (t->VAR_DECL.Name);
# line 1541 "Semantic.puma"
if (VarDistribution (Obj) == -1)
error_protocol ("Host variable in PURE subprogram not allowed");
}
return;
}
}
}
if (t->Kind == kACF_LIST) {
# line 1546 "Semantic.puma"
{
# line 1547 "Semantic.puma"
set_protocol_stmt (t->ACF_LIST.Elem);
# line 1548 "Semantic.puma"
SemPureCheck (t->ACF_LIST.Elem);
# line 1549 "Semantic.puma"
SemPureCheck (t->ACF_LIST.Next);
}
return;
}
if (t->Kind == kACF_BASIC) {
if (t->ACF_BASIC.BASIC_STMT->Kind == kIO_STMT) {
# line 1552 "Semantic.puma"
{
# line 1553 "Semantic.puma"
error_protocol ("IO in pure function/subroutine not allowed");
}
return;
}
if (t->ACF_BASIC.BASIC_STMT->Kind == kCALL_STMT) {
# line 1556 "Semantic.puma"
{
# line 1557 "Semantic.puma"
if (! (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Object == GetDeclEntry (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Ident, GetUnitEntries ()))) goto yyL6;
{
# line 1559 "Semantic.puma"
if (! ((IsPureObj (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Object) == false))) goto yyL6;
{
# line 1560 "Semantic.puma"
error_protocol ("CALL of not pure subroutine in PURE subprogram");
}
}
}
return;
yyL6:;
}
}
;
}
void BeginSemantic ()
{
}
void CloseSemantic ()
{
}